perm filename CURV2.F4[SAB,LCS] blob
sn#349443 filedate 1978-04-15 generic text, type C, neo UTF8
COMMENT ā VALID 00002 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 SUBROUTINE CURVE(X,Y,N,NSTEP,K)
C00005 ENDMK
Cā;
SUBROUTINE CURVE(X,Y,N,NSTEP,K)
DIMENSION X(3),Y(3),A(4),B(4)
EQUIVALENCE (A1,A(1)),(A2,A(2)),(A3,A(3)),(A4,A(4)),
1 (B1,B(1)),(B2,B(2)),(B3,B(3)),(B4,B(4))
CALL PLOT(X(1),Y(1),3)
NM1=N-1
NM2=N-2
DELT=1./FLOAT(NSTEP)
GO TO(1,2)K
1 A3 = X(2)-X(1)
B3 = Y(2)-Y(1)
A4 = X(3)-X(2)
B4 = Y(3)-Y(2)
IF(A3*B4-A4*B3.GT..001)GO TO 14
A1 = A4
B1 = B4
A2 = A3
B2 = B3
GO TO 15
14 A1 = 3.*A3-2.*A4
B1 = 3.*B3-2.*B4
A2 = 2.*A3-A4
B2 = 2.*B3-B4
GO TO 15
2 A1 = X(NM1)-X(NM2)
A2 = X(N)-X(NM1)
A3 = X(2)-X(1)
A4 = X(3)-X(2)
B1 = Y(NM1)-Y(NM2)
B2 = Y(N)-Y(NM1)
B3 = Y(2)-Y(1)
B4 = Y(3)-Y(2)
15 DO 140 I = 1,N
IM1 = I-1
IF(I.LT.NM1)GO TO 30
GO TO(3,4)K
3 IF(A3*B2-A2*B3.GT..001)GO TO 6
A4 = A3
B4 = B3
GO TO 40
6 A4 = 2.*A3-A2
B4 = 2.*B3-B2
GO TO 40
4 IF(I.EQ.N-1)GO TO 5
A4 = X(3)-X(2)
B4 = Y(3)-Y(2)
GO TO 40
5 A4 = X(2)-X(1)
B4 = Y(2)-Y(1)
GO TO 40
30 IP1 = I+1
IP2=I+2
A4 =X(IP2)-X(IP1)
B4= Y(IP2)-Y(IP1)
40 W2=ABS(A3*B4-A4*B3)
W3=ABS(A1*B2-A2*B1)
A0=W2*A2+W3*A3
B0=W2*B2+W3*B3
CC=A0**2 + B0**2
IF (CC.GT..0001) GO TO 50
A0=A2+A3
B0= B2+B3
CC=A0**2 +B0**2
50 DD=SQRT(CC)
C1=A0/DD
S1=B0/DD
IF (I.EQ.1) GO TO 120
RP=SQRT(A2*A2+B2*B2)
P0=X(IM1)
Q0=Y(IM1)
P1=RP*C0
Q1=RP*S0
P2=3.*A2-RP*(C1+2.*C0)
Q2=3.*B2-RP*(S1+2.*S0)
P3=-2.*A2+RP*(C1+C0)
Q3=-2.*B2+RP*(S1+S0)
DO 110 J=1,NSTEP
T=DELT*FLOAT(J)
XX=P0+T*(P1+T*(P2+T*P3))
YY=Q0+T*(Q1+T*(Q2+T*Q3))
CALL PLOT(XX,YY,2)
110 CONTINUE
120 C0=C1
S0=S1
DO 130 J=1,3
JP1= J+1
A(J)=A(JP1)
B(J)=B(JP1)
130 CONTINUE
140 CONTINUE
RETURN
END